home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_PRO / DS-1.ZIP;1 / RUNTIME.ZIP / FMISC.R < prev    next >
Encoding:
Text File  |  1992-02-11  |  45.5 KB  |  1,678 lines
  1. /*
  2.  * File: fmisc.r
  3.  * Contents:
  4.  *  args, char, collect, copy, display, iand, icom, image, ior, ishift,
  5.  *  ixor, ord, name, runerr, seq, sort, sortf, type, variable
  6.  */
  7.  
  8. "args(p) - produce number of arguments for procedure p."
  9.  
  10. function{1} args(x)
  11.  
  12.    if !is:procedure(x) then
  13.       runerr(106, x)
  14.  
  15.    abstract {
  16.       return integer
  17.       }
  18.    inline {
  19.       return C_integer ((struct b_proc *)BlkLoc(x))->nparam;
  20.       }
  21. end
  22.  
  23. #if !COMPILER
  24. #ifdef ExternalFunctions
  25. #ifdef IconCalling
  26. /*
  27.  * callout - call a C routine with an argument count and a list of descriptors.
  28.  * #%#%
  29.  */
  30. function{1} callout(x[nargs])
  31.    body {
  32.       dptr retval;
  33.       struct pf_marker *newpfp;
  34.       register word *newsp = sp;
  35.       int signal;
  36.  
  37.    /*
  38.     * Build a procedure frame.  This is not normal for "built-in" procedures,
  39.     *  but we're preparing to call Icon back, if necessary.  To get rid of
  40.     *  this frame, on the way out signal a Pret.  The code between the dashed 
  41.     *  lines is copied largely from invoke().
  42.     */
  43.       newpfp = (struct pf_marker *)(newsp + 1);
  44.       newpfp->pf_nargs = nargs;
  45.       newpfp->pf_argp = argp;
  46.       newpfp->pf_pfp = pfp;
  47.       newpfp->pf_ilevel = ilevel;
  48.       newpfp->pf_scan = NULL;
  49.  
  50.       newpfp->pf_ipc = ipc;
  51.       newpfp->pf_gfp = gfp;
  52.       newpfp->pf_efp = efp;
  53.  
  54.       argp = cargp;    /* cargp is newargp in invoke() */
  55.       pfp = newpfp;
  56.       newsp += Vwsizeof(*pfp);
  57.    
  58.       efp = 0;
  59.       gfp = 0;
  60.  
  61.       sp = newsp;
  62.    /*------------------------------------------------------------------------*/
  63.  
  64.       /*
  65.        * Little cheat here.  Although this is a var-arg procedure, we need
  66.        *  at least one argument to get started: pretend there is a null on
  67.        *  the stack.  NOTE:  Actually, at present, varargs functions always
  68.        *  have at least one argument, so this doesn't plug the hole.
  69.        */
  70.       if (nargs < 1)
  71.          runerr(103, nulldesc);
  72.  
  73.       /*
  74.        * Call the 'C routine caller' with a pointer to an array of descriptors.
  75.        *  Note that these are being left on the stack. We are passing
  76.        *  the name of the routine as part of the convention of calling
  77.        *  routines with an argc/argv technique.
  78.        */
  79.       signal = -1;            /* presume successful completion */
  80.       retval = extcall(x, nargs, &signal);
  81.       if (signal >= 0) {
  82.          if (retval == NULL)
  83.             runerr(signal);
  84.          else
  85.             runerr(signal, retval); 
  86.          }
  87.       if (retval != NULL) {
  88.          Arg0 = *retval;
  89.          return A_Pret_uw;
  90.          }
  91.       else 
  92.          return A_Pfail_uw;
  93.       }
  94. end
  95.  
  96. #else                    /* IconCalling */
  97.  
  98. /*
  99.  * callout - call a C library routine (or any C routine which doesn't call Icon)
  100.  *   with an argument count and a list of descriptors.  This routine
  101.  *   doesn't build a procedure frame to prepare for calling Icon back.
  102.  */
  103. function{1} callout(x[nargs])
  104.    body {
  105.       dptr retval;
  106.       int signal;
  107.  
  108.       /*
  109.        * Little cheat here.  Although this is a var-arg procedure, we need
  110.        *  at least one argument to get started: pretend there is a null on
  111.        *  the stack.  NOTE:  Actually, at present, varargs functions always
  112.        *  have at least one argument, so this doesn't plug the hole.
  113.        */
  114.       if (nargs < 1)
  115.          runerr(103, nulldesc);
  116.  
  117.       /*
  118.        * Call the 'C routine caller' with a pointer to an array of descriptors.
  119.        *  Note that these are being left on the stack. We are passing
  120.        *  the name of the routine as part of the convention of calling
  121.        *  routines with an argc/argv technique.
  122.        */
  123.       signal = -1;            /* presume successful completiong */
  124.       retval = extcall(x, nargs, &signal);
  125.       if (signal >= 0) {
  126.          if (retval == NULL)
  127.             runerr(signal);
  128.          else
  129.             runerr(signal, *retval); 
  130.          }
  131.       if (retval != NULL) {
  132.          return *retval;
  133.          }
  134.       else 
  135.          fail;
  136.       }
  137. end
  138.  
  139. #endif                    /* IconCalling */
  140. #endif                     /* ExternalFunctions */
  141. #endif                    /* !COMPILER */
  142.  
  143.  
  144. "char(i) - produce a string consisting of character i."
  145.  
  146. function{1} char(i)
  147.  
  148.    if !cnv:C_integer(i) then
  149.       runerr(101,i)
  150.    abstract {
  151.       return string
  152.       }
  153.    body {
  154.       if (i < 0 || i > 255) {
  155.          irunerr(205, i);
  156.          errorfail;
  157.          }
  158.       return string(1, &allchars[FromAscii(i) & 0xFF]);
  159.       }
  160. end
  161.  
  162.  
  163. "collect(i1,i2) - call garbage collector to ensure i2 bytes in region i1."
  164. " no longer works."
  165.  
  166. function{1} collect(region, bytes)
  167.  
  168.    if !def:C_integer(region, (C_integer)0) then
  169.       runerr(101, region) 
  170.    if !def:C_integer(bytes, (C_integer)0) then
  171.       runerr(101, bytes)
  172.  
  173.    abstract {
  174.       return null
  175.       }
  176.    body {
  177.       if (bytes < 0) {
  178.          irunerr(205, bytes);
  179.          errorfail;
  180.          }
  181.       if (region < 0 || region > 3) {
  182.          irunerr(205, region);
  183.          errorfail;
  184.          }
  185.       if (collect((int)region,bytes))
  186.          return nulldesc;
  187.       else
  188.          fail;
  189.       }
  190. end
  191.  
  192.  
  193. "copy(x) - make a copy of object x."
  194.  
  195. function{1} copy(x)
  196.    abstract {
  197.       return type(x)
  198.       }
  199.    type_case x of {
  200.       null:
  201.       string:
  202.       cset:
  203.       integer:
  204.       real:
  205.       file:
  206.       procedure:
  207.       co_expression:
  208.          inline {
  209.             /*
  210.              * Copy the null value, integers, long integers, reals, files,
  211.              *    csets, procedures, and such by copying the descriptor.
  212.              *    Note that for integers, this results in the assignment
  213.              *    of a value, for the other types, a pointer is directed to
  214.              *    a data block.
  215.              */
  216.             return x;
  217.             }
  218.  
  219.       list:
  220.          inline {
  221.             /*
  222.              * Pass the buck to cplist to copy a list.
  223.              */
  224.             if (cplist(&x, &result, (word)1, BlkLoc(x)->list.size + 1) ==Error)
  225.            runerr(0);
  226.             return result;
  227.             }
  228.       table: {
  229.          body {
  230.             register int i;
  231.             register word slotnum;
  232.             tended union block *src;
  233.             tended union block *dst;
  234.         tended struct b_slots *seg;
  235.         tended struct b_telem *ep, *prev;
  236.         struct b_telem *te;
  237.             /*
  238.              * Copy a Table.  First, allocate and copy header and slot blocks.
  239.              */
  240.             src = BlkLoc(x);
  241.             dst = hmake(T_Table, src->table.mask + 1, src->table.size);
  242.             if (dst == NULL)
  243.                runerr(0);
  244.             dst->table.size = src->table.size;
  245.             dst->table.mask = src->table.mask;
  246.             dst->table.defvalue = src->table.defvalue;
  247.             for (i = 0; i < HSegs && src->table.hdir[i] != NULL; i++)
  248.                memcopy((char *)dst->table.hdir[i], (char *)src->table.hdir[i],
  249.                   src->table.hdir[i]->blksize);
  250.             /*
  251.              * Work down the chain of element blocks in each bucket
  252.              *    and create identical chains in new table.
  253.              */
  254.             for (i = 0; i < HSegs && (seg = dst->table.hdir[i]) != NULL; i++)
  255.                for (slotnum = segsize[i] - 1; slotnum >= 0; slotnum--)  {
  256.           prev = NULL;
  257.                   for (ep = (struct b_telem *)seg->hslots[slotnum];
  258.             ep != NULL; ep = (struct b_telem *)ep->clink) {
  259.              Protect(te = alctelem(), runerr(0));
  260.              *te = *ep;                /* copy table entry */
  261.              if (prev == NULL)
  262.             seg->hslots[slotnum] = (union block *)te;
  263.              else
  264.             prev->clink = (union block *)te;
  265.              te->clink = ep->clink;
  266.              prev = te;
  267.                      }
  268.                   }
  269.  
  270.             if (TooSparse(dst))
  271.                hshrink(dst);
  272.         return table(dst);
  273.             }
  274.          }
  275.  
  276.       set: {
  277.          body {
  278.             /*
  279.              * Pass the buck to cpset to copy a set.
  280.              */
  281.             if (cpset(&x, &result, BlkLoc(x)->set.size) == Error)
  282.                runerr(0);
  283.         return result;
  284.             }
  285.          }
  286.  
  287.       record: {
  288.          body {
  289.             /*
  290.              * Note, these pointers don't need to be tended, because they are
  291.              *  not used until after allocation is complete.
  292.              */
  293.             struct b_record *new_rec;
  294.             tended struct b_record *old_rec;
  295.             dptr d1, d2;
  296.             int i;
  297.  
  298.             /*
  299.              * Allocate space for the new record and copy the old
  300.              *    one into it.
  301.              */
  302.             old_rec = (struct b_record *)BlkLoc(x);
  303.             i = old_rec->recdesc->proc.nfields;
  304.  
  305.             /* #%#% param changed ? */
  306.             Protect(new_rec = alcrecd(i,old_rec->recdesc), runerr(0));
  307.             d1 = new_rec->fields;
  308.             d2 = old_rec->fields;
  309.             while (i--)
  310.                *d1++ = *d2++;
  311.             return record(new_rec);
  312.             }
  313.          }
  314.  
  315.       default: body {
  316. #if Never
  317.          if (Type(x) == T_External) {
  318.             word n;
  319.             tended union block *op, *bp;
  320.  
  321.             /*
  322.              * Duplicate the block.  Recover number of data words in block,
  323.              * then allocate new block and copy the data.
  324.              */
  325.             op = BlkLoc(x);
  326.             n = (op->externl.blksize - (sizeof(struct b_external) - 
  327.                  sizeof(word))) / sizeof(word);
  328.             Protect(bp = (union block *)alcextrnl(n), runerr(0));
  329.             while (n--)
  330.                bp->externl.exdata[n] = op->externl.exdata[n];
  331.             result.dword = D_External;
  332.             BlkLoc(result) = bp;
  333.         return result;
  334.             }
  335.          else
  336. #endif                    /* Never */
  337.             runerr(123,x);
  338.          }
  339.          }
  340. end
  341.  
  342.  
  343. "display(i,f) - display local variables of i most recent"
  344. " procedure activations, plus global variables."
  345. " Output to file f (default &errout)."
  346.  
  347. #ifdef MultiThread
  348. function{1} display(i,f,c)
  349. declare { struct b_coexpr *ce = NULL; }
  350. #else                    /* MultiThread */
  351. function{1} display(i,f)
  352. #endif                    /* MultiThread */
  353.  
  354.    if !def:C_integer(i,(C_integer)k_level) then
  355.       runerr(101, i)
  356.  
  357.    if is:null(f) then
  358.        inline {
  359.           f = errout;
  360.           }
  361.    else if !is:file(f) then
  362.       runerr(105, f)
  363.  
  364. #ifdef MultiThread
  365.    if !is:null(c) then inline {
  366.       if (!is:co_expression(c)) runerr(118,c);
  367.       else if (BlkLoc(c) != BlkLoc(k_current))
  368.          ce = (struct b_coexpr *)BlkLoc(c);
  369.       }
  370. #endif                        /* MultiThread */
  371.  
  372.    abstract {
  373.       return null
  374.       }
  375.  
  376.    body {
  377.       FILE *std_f;
  378.       int r;
  379.  
  380.       if (!debug_info)
  381.          runerr(402);
  382.  
  383.       /*
  384.        * Produce error if file cannot be written.
  385.        */
  386.       std_f = BlkLoc(f)->file.fd;
  387.       if ((BlkLoc(f)->file.status & Fs_Write) == 0) 
  388.          runerr(213, f);
  389.  
  390.       /*
  391.        * Produce error if i is negative; constrain i to be >= &level.
  392.        */
  393.       if (i < 0) {
  394.          irunerr(205, i);
  395.          errorfail;
  396.          }
  397.       else if (i > k_level)
  398.          i = k_level;
  399.  
  400.       fprintf(std_f,"co-expression_%ld(%ld)\n\n",BlkLoc(k_current)->coexpr.id,
  401.          BlkLoc(k_current)->coexpr.size);
  402.       fflush(std_f);
  403. #ifdef MultiThread
  404.       if (ce)
  405.          r = xdisp(ce->es_pfp, ce->es_argp, (int)i, std_f);
  406.       else
  407. #endif                        /* MultiThread */
  408.          r = xdisp(pfp, argp, (int)i, std_f);
  409.       if (r == Failed)
  410.          runerr(305);
  411.       return nulldesc;
  412.       }
  413. end
  414.  
  415.  
  416. "errorclear() - clear error condition."
  417.  
  418. function{1} errorclear()
  419.    abstract {
  420.       return null
  421.       }
  422.    body {
  423.       k_errornumber = 0;
  424.       k_errortext = "";
  425.       k_errorvalue = nulldesc;
  426.       have_errval = 0;
  427.       return nulldesc;
  428.       }
  429. end
  430.  
  431. #if !COMPILER
  432.  
  433. "function() - generate the names of the functions."
  434.  
  435. function{*} function()
  436.    abstract {
  437.       return string
  438.       }
  439.    body {
  440.       register int i;
  441.  
  442.       for (i = 0; i<pnsize; i++) {
  443.      if (isalpha(pntab[i].pstrep[0])) /* only suspend function names */
  444.         suspend string(strlen(pntab[i].pstrep), pntab[i].pstrep);
  445.          }
  446.       fail;
  447.       }
  448. end
  449. #endif                    /* !COMPILER */
  450.  
  451.  
  452. /*
  453.  * the bitwise operators are identical enough to be expansions
  454.  *  of a macro.
  455.  */
  456.  
  457. #begdef  bitop(func_name, c_op, operation)
  458. #func_name "(i,j) - produce bitwise " operation " of i and j."
  459. function{1} func_name(i,j)
  460.    /*
  461.     * i and j must be integers
  462.     */
  463.    if !cnv:integer(i) then
  464.       runerr(101,i)
  465.    if !cnv:integer(j) then
  466.       runerr(101,j)
  467.  
  468.    abstract {
  469.       return integer
  470.       }
  471.    inline {
  472. #ifdef LargeInts
  473.       if ((Type(i)==T_Lrgint) || (Type(j)==T_Lrgint)) {
  474.          big_ ## c_op(i,j);
  475.          }
  476.       else
  477. #endif                    /* LargeInts */
  478.       return C_integer IntVal(i) c_op IntVal(j);
  479.       }
  480. end
  481. #enddef
  482.  
  483. #define bitand &
  484. #define bitor  |
  485. #define bitxor ^
  486. #begdef big_bitand(x,y)
  487. {
  488.    if (bigand(&x, &y, &result) == Error)  /* alcbignum failed */
  489.       runerr(0);
  490.    return result;
  491. }
  492. #enddef
  493. #begdef big_bitor(x,y)
  494. {
  495.    if (bigor(&x, &y, &result) == Error)  /* alcbignum failed */
  496.       runerr(0);
  497.    return result;
  498. }
  499. #enddef
  500. #begdef big_bitxor(x,y)
  501. {
  502.    if (bigxor(&x, &y, &result) == Error)  /* alcbignum failed */
  503.       runerr(0);
  504.    return result;
  505. }
  506. #enddef
  507.  
  508. bitop(iand, bitand, "AND")          /* iand(i,j) bitwise "and" of i and j */
  509. bitop(ior,  bitor, "inclusive OR")  /* ior(i,j) bitwise "or" of i and j */
  510. bitop(ixor, bitxor, "exclusive OR") /* ixor(i,j) bitwise "xor" of i and j */
  511.  
  512.  
  513. "icom(i) - produce bitwise complement (one's complement) of i."
  514.  
  515. function{1} icom(i)
  516.    /*
  517.     * i must be an integer
  518.     */
  519.    if !cnv:integer(i) then
  520.       runerr(101, i)
  521.  
  522.    abstract {
  523.       return integer
  524.       }
  525.    inline {
  526. #ifdef LargeInts
  527.       if (Type(i) == T_Lrgint) {
  528.          struct descrip td;
  529.  
  530.          td.dword = D_Integer;
  531.          IntVal(td) = -1;
  532.          if (bigsub(&td, &i, &result) == Error)  /* alcbignum failed */
  533.             runerr(0);
  534.          return result;
  535.          }
  536.       else
  537. #endif                    /* LargeInts */
  538.       return C_integer ~IntVal(i);
  539.       }
  540. end
  541.  
  542.  
  543. "image(x) - return string image of object x."
  544. /*
  545.  *  All the interesting work happens in getimage()
  546.  */
  547. function{1} image(x)
  548.    abstract {
  549.       return string
  550.       }
  551.    inline {
  552.       register int i;
  553.       if (getimage(&x,&result) == Error)
  554.           runerr(0);
  555.       return result;
  556.       }
  557. end
  558.  
  559.  
  560. "ishift(i,j) - produce i shifted j bit positions (left if j<0, right if j>0)."
  561.  
  562. function{1} ishift(i,j)
  563.  
  564.    if !cnv:integer(i) then
  565.       runerr(101, i)
  566.    if !cnv:integer(j) then
  567.       runerr(101, j)
  568.  
  569.    abstract {
  570.       return integer
  571.       }
  572.    body {
  573.       uword ci;             /* shift in 0s, even if negative */
  574.       C_integer cj;
  575. #ifdef LargeInts
  576.       if (Type(j) == T_Lrgint)
  577.          runerr(101,j);
  578.       if (Type(i) == T_Lrgint || IntVal(j)>0) {
  579.          if (bigshift(&i, &j, &result) == Error)  /* alcbignum failed */
  580.             runerr(0);
  581.          return result;
  582.          }
  583. #endif                    /* LargeInts */
  584.       ci = (uword)IntVal(i);
  585.       cj = IntVal(j);
  586.       /*
  587.        * Check for a shift of WordSize or greater; return an explicit 0 because
  588.        *  this is beyond C's defined behavior.  Otherwise shift as requested.
  589.        */
  590.       if (cj <= -WordBits || cj >= WordBits)
  591.          return C_integer 0;
  592.       else if (cj < 0)
  593.          return C_integer ci >> -cj;
  594.       else
  595.          return C_integer ci << cj;
  596.       }
  597. end
  598.  
  599.  
  600. "ord(s) - produce integer ordinal (value) of single chracter."
  601.  
  602. function{1} ord(s)
  603.    if !cnv:tmp_string(s) then
  604.       runerr(103, s)
  605.    abstract {
  606.       return integer
  607.       }
  608.    body {
  609.       if (StrLen(s) != 1)
  610.          runerr(205, s);
  611.       return C_integer ToAscii(*StrLoc(s) & 0xFF);
  612.       }
  613. end
  614.  
  615.  
  616. "name(v) - return the name of a variable."
  617.  
  618. #ifdef MultiThread
  619. function{1} name(underef v, c)
  620.    declare {
  621.       struct progstate *prog, *savedprog;
  622.       }
  623. #else                        /* MultiThread */
  624. function{1} name(underef v)
  625. #endif                        /* MultiThread */
  626.    /*
  627.     * v must be a variable
  628.     */
  629.    if !is:variable(v) then
  630.       runerr(111, v);
  631.  
  632.    abstract {
  633.       return string
  634.       }
  635.  
  636.    body {
  637.       C_integer i;
  638.       if (!debug_info)
  639.          runerr(402);
  640.  
  641. #ifdef MultiThread
  642.       savedprog = curpstate;
  643.       if (is:null(c)) {
  644.          prog = curpstate;
  645.          }
  646.       else if (is:co_expression(c)) {
  647.          prog = BlkLoc(c)->coexpr.program;
  648.          }
  649.       else {
  650.          runerr(118,c);
  651.          }
  652.  
  653.       ENTERPSTATE(prog);
  654. #endif                        /* MultiThread */
  655.       i = get_name(&v, &result);        /* return val ? #%#% */
  656.  
  657. #ifdef MultiThread
  658.       ENTERPSTATE(savedprog);
  659. #endif                        /* MultiThread */
  660.  
  661.       if (i == Error)
  662.          runerr(0);
  663.       return result;
  664.       }
  665. end
  666.  
  667.  
  668. "runerr(i,x) - produce runtime error i with value x."
  669.  
  670. function{} runerr(i,x[n])
  671.  
  672.    if !cnv:C_integer(i) then
  673.       runerr(101,i)
  674.    body {
  675.       if (i <= 0) {
  676.          irunerr(205,i);
  677.          errorfail;
  678.          }
  679.       if (n == 0) 
  680.          runerr((int)i);
  681.       else
  682.          runerr((int)i, x[0]);
  683.       }
  684. end
  685.  
  686.  
  687. "seq(i, j) - generate i, i+j, i+2*j, ... ."
  688.  
  689. function{1,*} seq(from, by)
  690.  
  691.    if !def:C_integer(from, 1) then
  692.       runerr(101, from)
  693.    if !def:C_integer(by, 1) then
  694.       runerr(101, by)
  695.    abstract {
  696.       return integer
  697.       }
  698.    body {
  699.       word seq_lb, seq_ub;
  700.  
  701.       /*
  702.        * Produce error if by is 0, i.e., an infinite sequence of from's.
  703.        */
  704.       if (by > 0) {
  705.          seq_lb = MinLong + by;
  706.          seq_ub = MaxLong;
  707.          }
  708.       else if (by < 0) {
  709.          seq_lb = MinLong;
  710.          seq_ub = MaxLong + by;
  711.          }
  712.       else if (by == 0) {
  713.          irunerr(211, by);
  714.          errorfail;
  715.  
  716.          }
  717.  
  718.       /*
  719.        * Suspend sequence, stopping when largest or smallest integer
  720.        *  is reached.
  721.        */
  722.       do {
  723.          suspend C_integer from;
  724.          from += by;
  725.          }
  726.       while (from >= seq_lb && from <= seq_ub);
  727.  
  728. #if !COMPILER
  729. #ifdef TraceBack
  730.       {
  731.       /*
  732.        * Suspending wipes out some things needed by the trace back code to
  733.        *  render the offending expression. Restore them.
  734.        */
  735.  
  736. #include "../h/opdefs.h"
  737.  
  738.       extern dptr xargp;
  739.       extern word xnargs;
  740.  
  741. #ifndef MultiThread
  742.       extern word lastop;               /* last op-code */
  743. #endif                                  /* MultiThread */
  744.  
  745.       lastop = Op_Invoke;
  746.       xnargs = 2;
  747.       xargp = r_args;
  748.       r_args[0].dword = D_Proc;
  749.       r_args[0].vword.bptr = (union block *)&Bseq;
  750.       }
  751. #endif                    /* TraceBack */
  752. #endif                    /* COMPILER */
  753.  
  754.       runerr(203);
  755.       }
  756. end
  757.  
  758.  
  759. "sort(x,i) - sort list, set, or table x by method i (for tables)"
  760.  
  761. function{1} sort(t, i)
  762.    type_case t of {
  763.       list: {
  764.          abstract {
  765.             return type(t)
  766.             }
  767.          body {
  768.             register word size;
  769.  
  770.             /*
  771.              * Sort the list by copying it into a new list and then using
  772.              *  qsort to sort the descriptors.  (That was easy!)
  773.              */
  774.             size = BlkLoc(t)->list.size;
  775.             if (cplist(&t, &result, (word)1, size + 1) == Error)
  776.            runerr(0);
  777.             qsort((char *)BlkLoc(result)->list.listhead->lelem.lslots,
  778.                (int)size, sizeof(struct descrip), (int (*)()) anycmp);
  779.             return result;
  780.             }
  781.          }
  782.  
  783.       set: {
  784.          abstract {
  785.             return new list(store[type(t).set_elem])
  786.             }
  787.          body {
  788.             register dptr d1;
  789.             register word size;
  790.             register int j, k;
  791.             tended struct b_list *lp;
  792.             union block *ep, *bp;
  793.             register struct b_slots *seg;
  794.             /*
  795.              * Create a list the size of the set, copy each element into
  796.              * the list, and then sort the list using qsort as in list
  797.              * sorting and return the sorted list.
  798.              */
  799.             size = BlkLoc(t)->set.size;
  800.  
  801.             Protect(lp = alclist(size), runerr(0));
  802.             Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0));
  803.             lp->listhead = lp->listtail = ep;
  804.             bp = BlkLoc(t);  /* need not be tended if not set until now */
  805.  
  806.             if (size > 0) {  /* only need to sort non-empty sets */
  807.                d1 = lp->listhead->lelem.lslots;
  808.                for (j = 0; j < HSegs && (seg = bp->table.hdir[j]) != NULL; j++)
  809.                   for (k = segsize[j] - 1; k >= 0; k--)
  810.                      for (ep = seg->hslots[k]; ep != NULL; ep= ep->telem.clink)
  811.                         *d1++ = ep->selem.setmem;
  812.                qsort((char *)lp->listhead->lelem.lslots,(int)size,
  813.                      sizeof(struct descrip), (int (*)())anycmp);
  814.                }
  815.             return list(lp);
  816.             }
  817.          }
  818.  
  819.       table: {
  820.          abstract {
  821.             return new list(new list(store[type(t).key ++ type(t).tbl_elem]) ++
  822.                store[type(t).key ++ type(t).tbl_elem])
  823.             }
  824.          if !def:C_integer(i, 1) then
  825.             runerr(101, i)
  826.          body {
  827.             register dptr d1;
  828.             register word size;
  829.             register int j, k, n;
  830.         tended struct b_table *bp;
  831.             tended struct b_list *lp, *tp;
  832.             tended union block *ep, *ev;
  833.         tended struct b_slots *seg;
  834.  
  835.             switch (i) {
  836.  
  837.             /*
  838.              * Cases 1 and 2 are as in standard Version 5.
  839.              */
  840.                case 1:
  841.                case 2:
  842.               {
  843.                /*
  844.                 * The list resulting from the sort will have as many elements
  845.                 *  as the table has, so get that value and also make a valid
  846.                 *  list block size out of it.
  847.                 */
  848.                size = BlkLoc(t)->table.size;
  849.  
  850.            /*
  851.         * Make sure, now, that there's enough room for all the
  852.         *  allocations we're going to need.
  853.         */
  854.            if (!blkreserve((word)(sizeof(struct b_list)
  855.           + sizeof(struct b_lelem) + (size - 1) * sizeof(struct descrip)
  856.           + size * sizeof(struct b_list)
  857.           + size * (sizeof(struct b_lelem) + sizeof(struct descrip)))))
  858.           runerr(0);
  859.                /*
  860.                 * Point bp at the table header block of the table to be sorted
  861.                 *  and point lp at a newly allocated list
  862.                 *  that will hold the the result of sorting the table.
  863.                 */
  864.                bp = (struct b_table *)BlkLoc(t);
  865.                Protect(lp = alclist(size), runerr(0));
  866.                Protect(ep=(union block *)alclstb(size,(word)0,size),runerr(0));
  867.                lp->listtail = lp->listhead = ep;
  868.                /*
  869.                 * If the table is empty, there is no need to sort anything.
  870.                 */
  871.                if (size <= 0)
  872.                   break;
  873.                /*
  874.                 * Traverse the element chain for each table bucket.  For each
  875.                 *  element, allocate a two-element list and put the table
  876.                 *  entry value in the first element and the assigned value in
  877.                 *  the second element.  The two-element list is assigned to
  878.                 *  the descriptor that d1 points at.  When this is done, the
  879.                 *  list of two-element lists is complete, but unsorted.
  880.                 */
  881.  
  882.                n = 0;                /* list index */
  883.                for (j = 0; j < HSegs && (seg = bp->hdir[j]) != NULL; j++)
  884.                   for (k = segsize[j] - 1; k >= 0; k--)
  885.                      for (ep= seg->hslots[k]; ep != NULL; ep= ep->telem.clink){
  886.                         Protect(tp = alclist((word)2), runerr(0));
  887.                         Protect(ev = (union block *)alclstb((word)2, (word)0, (word)2), runerr(0));
  888.                         tp->listhead = tp->listtail = ev;
  889.                         tp->listhead->lelem.lslots[0] = ep->telem.tref;
  890.                         tp->listhead->lelem.lslots[1] = ep->telem.tval;
  891.                         d1 = &lp->listhead->lelem.lslots[n++];
  892.                         d1->dword = D_List;
  893.                         BlkLoc(*d1) = (union block *)tp;
  894.                         }
  895.                /*
  896.                 * Sort the resulting two-element list using the sorting
  897.                 *  function determined by i.
  898.                 */
  899.                if (i == 1)
  900.                   qsort((char *)lp->listhead->lelem.lslots, (int)size,
  901.                         sizeof(struct descrip), (int (*)())trefcmp);
  902.                else
  903.                   qsort((char *)lp->listhead->lelem.lslots, (int)size,
  904.                         sizeof(struct descrip), (int (*)())tvalcmp);
  905.                break;        /* from cases 1 and 2 */
  906.                }
  907.             /*
  908.              * Cases 3 and 4 were introduced in Version 5.10.
  909.              */
  910.                case 3 :
  911.                case 4 :
  912.                        {
  913.             /*
  914.              * The list resulting from the sort will have twice as many
  915.              *  elements as the table has, so get that value and also make
  916.              *  a valid list block size out of it.
  917.              */
  918.             size = BlkLoc(t)->table.size * 2;
  919.  
  920.             /*
  921.              * Point bp at the table header block of the table to be sorted
  922.              *  and point lp at a newly allocated list
  923.              *  that will hold the the result of sorting the table.
  924.              */
  925.             bp = (struct b_table *)BlkLoc(t);
  926.             Protect(lp = alclist(size), runerr(0));
  927.             Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0));
  928.             lp->listhead = lp->listtail = ep;
  929.             /*
  930.              * If the table is empty there's no need to sort anything.
  931.              */
  932.             if (size <= 0)
  933.                break;
  934.  
  935.             /*
  936.              * Point d1 at the start of the list elements in the new list
  937.              *  element block in preparation for use as an index into the list.
  938.              */
  939.             d1 = lp->listhead->lelem.lslots;
  940.             /*
  941.              * Traverse the element chain for each table bucket.  For each
  942.              *  table element copy the the entry descriptor and the value
  943.              *  descriptor into adjacent descriptors in the lslots array
  944.              *  in the list element block.
  945.              *  When this is done we now need to sort this list.
  946.              */
  947.  
  948.             for (j = 0; j < HSegs && (seg = bp->hdir[j]) != NULL; j++)
  949.                for (k = segsize[j] - 1; k >= 0; k--)
  950.                   for (ep = seg->hslots[k]; ep != NULL; ep = ep->telem.clink) {
  951.                      *d1++ = ep->telem.tref;
  952.                      *d1++ = ep->telem.tval;
  953.                      }
  954.             /*
  955.              * Sort the resulting two-element list using the
  956.              *  sorting function determined by i.
  957.              */
  958.             if (i == 3)
  959.                qsort((char *)lp->listhead->lelem.lslots, (int)size / 2,
  960.                      (2 * sizeof(struct descrip)), (int (*)())trcmp3);
  961.             else
  962.                qsort((char *)lp->listhead->lelem.lslots, (int)size / 2,
  963.                      (2 * sizeof(struct descrip)), (int (*)())tvcmp4);
  964.             break; /* from case 3 or 4 */
  965.                }
  966.  
  967.             default: {
  968.                irunerr(205, i);
  969.                errorfail;
  970.                }
  971.  
  972.             } /* end of switch statement */
  973.  
  974.             /*
  975.              * Make result point at the sorted list.
  976.              */
  977.             return list(lp);
  978.             }
  979.          }
  980.  
  981.       default:
  982.          runerr(115, t);
  983.       }
  984. end
  985.  
  986. /*
  987.  * trefcmp(d1,d2) - compare two-element lists on first field.
  988.  */
  989.  
  990. int trefcmp(d1,d2)
  991. dptr d1, d2;
  992.    {
  993.  
  994. #ifdef DeBug
  995.    if (d1->dword != D_List || d2->dword != D_List)
  996.       syserr("trefcmp: internal consistency check fails.");
  997. #endif                    /* DeBug */
  998.  
  999.    return (anycmp(&(BlkLoc(*d1)->list.listhead->lelem.lslots[0]),
  1000.                   &(BlkLoc(*d2)->list.listhead->lelem.lslots[0])));
  1001.    }
  1002.  
  1003. /*
  1004.  * tvalcmp(d1,d2) - compare two-element lists on second field.
  1005.  */
  1006.  
  1007. int tvalcmp(d1,d2)
  1008. dptr d1, d2;
  1009.    {
  1010.  
  1011. #ifdef DeBug
  1012.    if (d1->dword != D_List || d2->dword != D_List)
  1013.       syserr("tvalcmp: internal consistency check fails.");
  1014. #endif                    /* DeBug */
  1015.  
  1016.    return (anycmp(&(BlkLoc(*d1)->list.listhead->lelem.lslots[1]),
  1017.       &(BlkLoc(*d2)->list.listhead->lelem.lslots[1])));
  1018.    }
  1019.  
  1020. /*
  1021.  * The following two routines are used to compare descriptor pairs in the
  1022.  *  experimental table sort.
  1023.  *
  1024.  * trcmp3(dp1,dp2)
  1025.  */
  1026.  
  1027. int trcmp3(dp1,dp2)
  1028. struct dpair *dp1,*dp2;
  1029. {
  1030.    return (anycmp(&((*dp1).dr),&((*dp2).dr)));
  1031. }
  1032. /*
  1033.  * tvcmp4(dp1,dp2)
  1034.  */
  1035.  
  1036. int tvcmp4(dp1,dp2)
  1037. struct dpair *dp1,*dp2;
  1038.  
  1039.    {
  1040.    return (anycmp(&((*dp1).dv),&((*dp2).dv)));
  1041.    }
  1042.  
  1043.  
  1044. "sortf(x,i) - sort list or set x on field i of each member"
  1045.  
  1046. function{1} sortf(t, i)
  1047.    type_case t of {
  1048.       list: {
  1049.          abstract {
  1050.             return type(t)
  1051.             }
  1052.          if !def:C_integer(i, 1) then
  1053.             runerr (101, i)
  1054.          body {
  1055.             register word size;
  1056.             extern word sort_field;
  1057.  
  1058.             if (i == 0) {
  1059.                irunerr(205, i);
  1060.                errorfail;
  1061.                }
  1062.             /*
  1063.              * Sort the list by copying it into a new list and then using
  1064.              *  qsort to sort the descriptors.  (That was easy!)
  1065.              */
  1066.             size = BlkLoc(t)->list.size;
  1067.             if (cplist(&t, &result, (word)1, size + 1) == Error)
  1068.                runerr(0);
  1069.             sort_field = i;
  1070.             qsort((char *)BlkLoc(result)->list.listhead->lelem.lslots,
  1071.                (int)size, sizeof(struct descrip), (int (*)()) nthcmp);
  1072.             return result;
  1073.             }
  1074.          }
  1075.  
  1076.       set: {
  1077.          abstract {
  1078.             return new list(store[type(t).set_elem])
  1079.             }
  1080.          if !def:C_integer(i, 1) then
  1081.             runerr (101, i)
  1082.          body {
  1083.             register dptr d1;
  1084.             register word size;
  1085.             register int j, k;
  1086.             tended struct b_list *lp;
  1087.             union block *ep, *bp;
  1088.             register struct b_slots *seg;
  1089.             extern word sort_field;
  1090.  
  1091.             if (i == 0) {
  1092.                irunerr(205, i);
  1093.                errorfail;
  1094.                }
  1095.             /*
  1096.              * Create a list the size of the set, copy each element into
  1097.              * the list, and then sort the list using qsort as in list
  1098.              * sorting and return the sorted list.
  1099.              */
  1100.             size = BlkLoc(t)->set.size;
  1101.  
  1102.             Protect(lp = alclist(size), runerr(0));
  1103.             Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0));
  1104.             lp->listhead = lp->listtail = ep;
  1105.             bp = BlkLoc(t);  /* need not be tended if not set until now */
  1106.  
  1107.             if (size > 0) {  /* only need to sort non-empty sets */
  1108.                d1 = lp->listhead->lelem.lslots;
  1109.                for (j = 0; j < HSegs && (seg = bp->table.hdir[j]) != NULL; j++)
  1110.                   for (k = segsize[j] - 1; k >= 0; k--)
  1111.                      for (ep = seg->hslots[k]; ep != NULL; ep= ep->telem.clink)
  1112.                         *d1++ = ep->selem.setmem;
  1113.                sort_field = i;
  1114.                qsort((char *)lp->listhead->lelem.lslots,(int)size,
  1115.                      sizeof(struct descrip), (int (*)())nthcmp);
  1116.                }
  1117.             return list(lp);
  1118.             }
  1119.          }
  1120.  
  1121.       default:
  1122.          runerr(125, t);    /* list or set expected */
  1123.       }
  1124. end
  1125.  
  1126. /*
  1127.  * nthcmp(d1,d2) - compare two descriptors on their nth fields.
  1128.  */
  1129. word sort_field;        /* field number, set by sort function */
  1130. static dptr nth Params((dptr d));
  1131.  
  1132. int nthcmp(d1,d2)
  1133. dptr d1, d2;
  1134.    {
  1135.    int t1, t2, rv;
  1136.    dptr e1, e2;
  1137.  
  1138.    t1 = Type(*d1);
  1139.    t2 = Type(*d2);
  1140.    if (t1 == t2 && (t1 == T_Record || t1 == T_List)) {
  1141.       e1 = nth(d1);        /* get nth field, or NULL if none such */
  1142.       e2 = nth(d2);
  1143.       if (e1 == NULL) {
  1144.          if (e2 != NULL)
  1145.             return -1;        /* no-nth-field is < any nth field */
  1146.          }
  1147.       else if (e2 == NULL)
  1148.      return 1;        /* any nth field is > no-nth-field */
  1149.       else {
  1150.      /*
  1151.       *  Both had an nth field.  If they're unequal, that decides.
  1152.       */
  1153.          rv = anycmp(nth(d1), nth(d2));
  1154.          if (rv != 0)
  1155.             return rv;
  1156.          }
  1157.       }
  1158.    /*
  1159.     * Comparison of nth fields was either impossible or indecisive.
  1160.     *  Settle it by comparing the descriptors directly.
  1161.     */
  1162.    return anycmp(d1, d2);
  1163.    }
  1164.  
  1165. /*
  1166.  * nth(d) - return the nth field of d, if any.  (sort_field is "n".)
  1167.  */
  1168. static dptr nth(d)
  1169. dptr d;
  1170.    {
  1171.    union block *bp;
  1172.    struct b_list *lp;
  1173.    word i, j;
  1174.    dptr rv;
  1175.  
  1176.    rv = NULL;
  1177.    if (d->dword == D_Record) {
  1178.       /*
  1179.        * Find the nth field of a record.
  1180.        */
  1181.       bp = BlkLoc(*d);
  1182.       i = cvpos((long)sort_field, (long)(bp->record.recdesc->proc.nfields));
  1183.       if (i != CvtFail && i <= bp->record.recdesc->proc.nfields)
  1184.          rv = &bp->record.fields[i-1];
  1185.       }
  1186.    else if (d->dword == D_List) {
  1187.       /*
  1188.        * Find the nth element of a list.
  1189.        */
  1190.       lp = (struct b_list *)BlkLoc(*d);
  1191.       i = cvpos ((long)sort_field, (long)lp->size);
  1192.       if (i != CvtFail && i <= lp->size) {
  1193.          /*
  1194.           * Locate the correct list-element block.
  1195.           */
  1196.          bp = lp->listhead;
  1197.          j = 1;
  1198.          while (i >= j + bp->lelem.nused) {
  1199.             j += bp->lelem.nused;
  1200.             bp = bp->lelem.listnext;
  1201.             }
  1202.          /*
  1203.           * Locate the desired element.
  1204.           */
  1205.          i += bp->lelem.first - j;
  1206.          if (i >= bp->lelem.nslots)
  1207.             i -= bp->lelem.nslots;
  1208.          rv = &bp->lelem.lslots[i];
  1209.          }
  1210.       }
  1211.    return rv;
  1212.    }
  1213.  
  1214.  
  1215. "type(x) - return type of x as a string."
  1216.  
  1217. function{1} type(x)
  1218.    abstract {
  1219.       return string
  1220.       }
  1221.    type_case x of {
  1222.       string:   inline { return C_string "string";    }
  1223.       null:     inline { return C_string "null";      }
  1224.       integer:  inline { return C_string "integer";   }
  1225.       real:     inline { return C_string "real";      }
  1226.       cset:     inline { return C_string "cset";      }
  1227.       file:     inline { return C_string "file";      }
  1228.       procedure:inline { return C_string "procedure"; }
  1229.       list:     inline { return C_string "list";      }
  1230.       table:    inline { return C_string "table";     }
  1231.       set:      inline { return C_string "set";       }
  1232.       record:   inline { return BlkLoc(x)->record.recdesc->proc.recname; }
  1233.       co_expression: inline { return C_string "co-expression"; }
  1234.       default:
  1235.          inline {
  1236. #if !COMPILER
  1237.             if (!Qual(x) && (Type(x)==T_External)) {
  1238.                return C_string "external";
  1239.                }
  1240.             else
  1241. #endif                    /* !COMPILER */
  1242.                runerr(123,x);
  1243.         }
  1244.       }
  1245. end
  1246.  
  1247.  
  1248. "variable(s) - find the variable with name s and return a"
  1249. " variable descriptor which points to its value."
  1250.  
  1251. #ifdef MultiThread
  1252. function{0,1} variable(s,c)
  1253. #else                        /* MultiThread */
  1254. function{0,1} variable(s)
  1255. #endif                        /* MultiThread */
  1256.  
  1257.    if !cnv:C_string(s) then
  1258.       runerr(103, s)
  1259.    abstract {
  1260.       return variable
  1261.       }
  1262.  
  1263.    body {
  1264.       register dptr dp;
  1265.       register dptr np;
  1266.       register int i;
  1267.       struct b_proc *bp;
  1268. #ifdef MultiThread
  1269.       struct progstate *prog, *savedprog;
  1270.  
  1271.       savedprog = curpstate;
  1272.       if (is:null(c)) {
  1273.          prog = curpstate;
  1274.          }
  1275.       else if (is:co_expression(c)) {
  1276.          prog = BlkLoc(c)->coexpr.program;
  1277.          }
  1278.       else {
  1279.          runerr(118,c);
  1280.          }
  1281.  
  1282.       ENTERPSTATE(prog);
  1283. #endif                        /* MultiThread */
  1284.  
  1285.       i = getvar(s,&result);
  1286.    
  1287. #ifdef MultiThread
  1288.       ENTERPSTATE(savedprog);
  1289. #endif                        /* MultiThread */
  1290.  
  1291.       if (i == Succeeded)
  1292.          return result;
  1293.       else
  1294.          fail;
  1295.       }
  1296. end
  1297.  
  1298. #ifdef MultiThread
  1299. #include "../h/opdefs.h"
  1300.  
  1301. "load(s,arglist,input,output,error,eventmask,opmask) - load an icode file"
  1302. " corresponding to string s as a co-expression."
  1303.  
  1304. function{1} load(s,arglist,infile,outfile,errfile,eventmask,opmask)
  1305.    declare {
  1306.       tended char *loadstring;
  1307.       }
  1308.    if !cnv:C_string(s,loadstring) then
  1309.       runerr(103,s)
  1310.    abstract {
  1311.       return co_expression
  1312.       }
  1313.    body {
  1314.       word *stack;
  1315.       struct progstate *pstate;
  1316.       char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen];
  1317.       register struct b_coexpr *sblkp;
  1318.       register struct b_refresh *rblkp;
  1319.       struct ef_marker *newefp;
  1320.       register dptr dp, ndp, dsp;
  1321.       register word *newsp, *savedsp;
  1322.       int na, nl, i, j, num_fileargs = 0;
  1323.       FILE *theInput = NULL, *theOutput = NULL, *theError = NULL;
  1324.       struct b_proc *cproc;
  1325.       dptr mask = NULL, omask = NULL;
  1326.  
  1327.       /*
  1328.        * Yeah, OK, I freely admit this isn't portable yet.  It isn't hard
  1329.        * to 16-ify, so I haven't bothered.
  1330.        */
  1331.       static int lterm[] = { Op_Cofail, Op_Agoto, 0 };
  1332.       static int pstart[] =
  1333.  
  1334. #ifdef EventMon
  1335.         { Op_SymEvents, Op_Invoke, 1, Op_Coret, Op_Cofail, Op_Agoto, 0 };
  1336. #else                    /* EventMon */
  1337.         { Op_Invoke, 1, Op_Coret, Op_Cofail, Op_Agoto, 0 };
  1338. #endif                    /* EventMon */
  1339.  
  1340. #ifdef EventMon
  1341.       lterm[2] = pstart[6] = (int)lterm;
  1342. #else                    /* EventMon */
  1343.       lterm[2] = pstart[5] = (int)lterm;
  1344. #endif                    /* EventMon */
  1345.  
  1346.       /*
  1347.        * arglist must be a list
  1348.        */
  1349.       if (!is:null(arglist) && !is:list(arglist))
  1350.          runerr(108,arglist);
  1351.  
  1352.       /*
  1353.        * input, output, and error must be files
  1354.        */
  1355.       if (is:null(infile))
  1356.      theInput = curpstate->input;
  1357.       else {
  1358.      if (!is:file(input))
  1359.         runerr(105,input);
  1360.      else theInput = BlkLoc(infile)->file.fd;
  1361.          }
  1362.       if (is:null(outfile))
  1363.      theOutput = curpstate->output;
  1364.       else {
  1365.      if (!is:file(outfile))
  1366.         runerr(105,outfile);
  1367.      else theOutput = BlkLoc(outfile)->file.fd;
  1368.          }
  1369.       if (is:null(errfile))
  1370.      theError = curpstate->errout;
  1371.       else {
  1372.      if (!is:file(errfile))
  1373.         runerr(105,errfile);
  1374.      else theError = BlkLoc(errfile)->file.fd;
  1375.          }
  1376.  
  1377.       /*
  1378.        * eventmask, and opmask must be csets
  1379.        */
  1380.       if (!is:null(eventmask)) {
  1381.      if (!is:cset(eventmask))
  1382.         runerr(104,eventmask);
  1383.      else mask = &eventmask;
  1384.          }
  1385.       if (!is:null(opmask)) {
  1386.      if (!is:cset(opmask))
  1387.         runerr(104,opmask);
  1388.      else mask = &opmask;
  1389.          }
  1390.  
  1391.       stack =
  1392.     (word *)(sblkp = loadicode(loadstring,theInput,theOutput,theError));
  1393.       if(!stack) {
  1394.          fprintf(stderr,"load/loadicode fails\n");
  1395.          c_exit(ErrorExit);
  1396.          }
  1397.       pstate = sblkp->program;
  1398.       pstate->parent = curpstate;
  1399.       pstate->parentdesc = k_main;
  1400.       if (mask) pstate->eventmask = *mask;
  1401.       if (omask) pstate->opcodemask = *omask;
  1402.  
  1403.       savedsp = sp;
  1404.       sp = stack + Wsizeof(struct b_coexpr)
  1405.         + Wsizeof(struct progstate) + pstate->hsize/WordSize;
  1406.       if (pstate->hsize % WordSize) sp++;
  1407.  
  1408. #ifdef UpStack
  1409.       sblkp->cstate[0] =
  1410.          ((word)((char *)sblkp + (mstksize - (sizeof(*sblkp)+sizeof(struct progstate)+pstate->hsize))/2)
  1411.             &~((word)WordSize*StackAlign-1));
  1412. #else                    /* UpStack */
  1413.       sblkp->cstate[0] =
  1414.     ((word)((char *)sblkp + mstksize - WordSize + sizeof(struct progstate) + pstate->hsize)
  1415.            &~((word)WordSize*StackAlign-1));
  1416. #endif                    /* UpStack */
  1417.  
  1418. #ifdef CoProcesses
  1419.       sblkp->cstate[1] = 0;
  1420. #endif                    /* CoProcesses */
  1421.  
  1422.       sblkp->es_argp = NULL;
  1423.       pstate->Mainhead->freshblk = nulldesc;/* &main has no refresh block. */
  1424.                     /*  This really is a bug. */
  1425.       /*
  1426.        * Set up expression frame marker to contain execution of the
  1427.        *  main procedure.  If failure occurs in this context, control
  1428.        *  is transferred to lterm, the address of an { Op_Coret, Op_Efail}.
  1429.        */
  1430.       newefp = (struct ef_marker *)(sp);
  1431.       newefp->ef_failure.op = &(lterm[0]);
  1432.  
  1433.       newefp->ef_gfp = 0;
  1434.       newefp->ef_efp = 0;
  1435.       newefp->ef_ilevel = ilevel/*1*/;
  1436.       sp += Wsizeof(*newefp) - 1;
  1437.  
  1438.       /*
  1439.        * The first global variable holds the value of "main".  If it
  1440.        *  is not of type procedure, this is noted as run-time error 117.
  1441.        *  Otherwise, this value is pushed on the stack.
  1442.        */
  1443.       if (pstate->Globals[0].dword != D_Proc)
  1444.          fatalerr(117, NULL);
  1445.  
  1446.       PushDesc(pstate->Globals[0]);
  1447.  
  1448.       /*
  1449.        * Create a list from arguments using Ollist and push a descriptor
  1450.        * onto new stack.  Then create procedure frame on new stack.  Push
  1451.        * two new null descriptors, and set sblkp->es_sp when all finished.
  1452.        */
  1453.       if (!is:null(arglist)) {
  1454.          PushDesc(arglist);
  1455.          }
  1456.       else {
  1457.          PushNull;
  1458.          {
  1459.          dptr tmpargp = (dptr) (sp - 1);
  1460.          Ollist(0, tmpargp);
  1461.          sp = (word *)tmpargp + 1;
  1462.          }
  1463.          }
  1464.       sblkp->es_sp = (word *)sp;
  1465.       sblkp->es_ipc.opnd = pstart;
  1466.  
  1467.       result.dword = D_Coexpr;
  1468.       BlkLoc(result) = (union block *)sblkp;
  1469.       sp = savedsp;
  1470.       return result;
  1471.       }
  1472. end
  1473.  
  1474.  
  1475. "program(ce) - given a ce, return &main for that ce"
  1476.  
  1477. function{1} program(ce)
  1478.    if is:null(ce) then inline { ce = k_current; }
  1479.    else if !is:co_expression(ce) then runerr(118,ce)
  1480.    abstract {
  1481.       return co_expression
  1482.       }
  1483.    body {
  1484.       result.dword = D_Coexpr;
  1485.       BlkLoc(result) =
  1486.     (union block *)(((struct b_coexpr *)BlkLoc(ce))->program->Mainhead);
  1487.       return result;
  1488.       }
  1489. end
  1490.  
  1491.  
  1492. "eventmask(ce,cs) - given a ce, get or set that program's event mask"
  1493.  
  1494. function{1} eventmask(ce,cs)
  1495.    if !is:co_expression(ce) then runerr(118,ce)
  1496.  
  1497.    if is:null(cs) then {
  1498.       abstract {
  1499.          return cset++null
  1500.          }
  1501.       body {
  1502.          result = BlkLoc(ce)->coexpr.program->eventmask;
  1503.          return result;
  1504.          }
  1505.       }
  1506.    else if !cnv:cset(cs) then runerr(104,cs)
  1507.    else {
  1508.       abstract {
  1509.          return cset
  1510.          }
  1511.       body {
  1512.          ((struct b_coexpr *)BlkLoc(ce))->program->eventmask = cs;
  1513.          return cs;
  1514.          }
  1515.       }
  1516. end
  1517.  
  1518.  
  1519. "fieldnames(r) - generate the fieldnames of record r"
  1520.  
  1521. function{*} fieldnames(r)
  1522.    if !is:record(r) then runerr(107,r)
  1523.    body {
  1524.       int i;
  1525.       for(i=0;i<BlkLoc(r)->record.recdesc->proc.nfields;i++) {
  1526.      suspend BlkLoc(r)->record.recdesc->proc.lnames[i];
  1527.          }
  1528.       fail;
  1529.       }
  1530. end
  1531.  
  1532.  
  1533.  
  1534. "globalnames(ce) - produce the names of identifiers global to ce"
  1535.  
  1536. function{*} globalnames(ce)
  1537.    declare {
  1538.       struct progstate *ps;
  1539.       }
  1540.    abstract {
  1541.       return string
  1542.       }
  1543.    if is:null(ce) then inline { ps = curpstate; }
  1544.    else if is:co_expression(ce) then
  1545.       inline { ps = BlkLoc(ce)->coexpr.program; }
  1546.    else runerr(118,ce)
  1547.    body {
  1548.       struct descrip *dp;
  1549.       for (dp = ps->Gnames; dp != ps->Egnames; dp++) {
  1550.          suspend *dp;
  1551.          }
  1552.       fail;
  1553.       }
  1554. end
  1555.  
  1556. "localnames(ce) - produce the names of local variables"
  1557. " in the current procedure activation in ce"
  1558. function{*} localnames(ce)
  1559.    declare {
  1560.       tended struct descrip d;
  1561.       }
  1562.    abstract {
  1563.       return string
  1564.       }
  1565.    if is:null(ce) then inline {
  1566.       d = k_current;
  1567.       BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */
  1568.       }
  1569.    else if is:co_expression(ce) then
  1570.       inline { d = ce; }
  1571.    else runerr(118,ce)
  1572.    body {
  1573.       int i;
  1574.       dptr arg;
  1575.       struct b_proc *cproc;
  1576.       struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp;
  1577.       arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1];
  1578.       cproc = (struct b_proc *)BlkLoc(arg[0]);    
  1579.       for(i=0; i<cproc->ndynam;i++) {
  1580.      result = cproc->lnames[i+cproc->nparam];
  1581.      suspend result;
  1582.          }
  1583.       fail;
  1584.       }
  1585. end
  1586.  
  1587.  
  1588. "opmask(ce,cs) - given a ce, set that program's opcode mask"
  1589.  
  1590. function{1} opmask(ce,cs)
  1591.    if !is:co_expression(ce) then runerr(118,ce)
  1592.  
  1593.    if is:null(cs) then {
  1594.       abstract {
  1595.          return cset++null
  1596.          }
  1597.       body {
  1598.          result = BlkLoc(ce)->coexpr.program->opcodemask;
  1599.          return result;
  1600.          }
  1601.       }
  1602.    else if !cnv:cset(cs) then runerr(104,cs)
  1603.    else {
  1604.       abstract {
  1605.          return cset
  1606.          }
  1607.       body {
  1608.          ((struct b_coexpr *)BlkLoc(ce))->program->opcodemask = cs;
  1609.          return cs;
  1610.          }
  1611.       }
  1612. end
  1613.  
  1614. "staticnames(ce) - produce the names of static variables"
  1615. " in the current procedure activation in ce"
  1616.  
  1617. function{*} staticnames(ce)
  1618.    declare {
  1619.       tended struct descrip d;
  1620.       }
  1621.    abstract {
  1622.       return string
  1623.       }
  1624.    if is:null(ce) then inline {
  1625.       d = k_current;
  1626.       BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */
  1627.       }
  1628.    else if is:co_expression(ce) then
  1629.       inline { d = ce; }
  1630.    else runerr(118,ce)
  1631.    body {
  1632.       int i;
  1633.       dptr arg;
  1634.       struct b_proc *cproc;
  1635.       struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp;
  1636.       arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1];
  1637.       cproc = (struct b_proc *)BlkLoc(arg[0]);    
  1638.       for(i=0; i<cproc->nstatic;i++) {
  1639.      result = cproc->lnames[i+cproc->nparam+cproc->ndynam];
  1640.      suspend result;
  1641.          }
  1642.       fail;
  1643.       }
  1644. end
  1645.  
  1646. "paramnames(ce) - produce the names of the parameters"
  1647. " in the current procedure activation in ce"
  1648.  
  1649. function{1,*} paramnames(ce)
  1650.    declare {
  1651.       tended struct descrip d;
  1652.       }
  1653.    abstract {
  1654.       return string
  1655.       }
  1656.    if is:null(ce) then inline {
  1657.       d = k_main;
  1658.       BlkLoc(k_main)->coexpr.es_pfp = pfp; /* sync w/ current value */
  1659.       }
  1660.    else if is:co_expression(ce) then
  1661.       inline { d = ce; }
  1662.    else runerr(118,ce)
  1663.    body {
  1664.       int i;
  1665.       dptr arg;
  1666.       struct b_proc *cproc;
  1667.       struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp;
  1668.       arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1];
  1669.       cproc = (struct b_proc *)BlkLoc(arg[0]);    
  1670.       for(i=0; i<cproc->nparam;i++) {
  1671.      result = cproc->lnames[i];
  1672.      suspend result;
  1673.          }
  1674.       fail;
  1675.       }
  1676. end
  1677. #endif                    /* MultiThread */
  1678.